Magnum One/Magnum One (Mid-American Digital) (Disc Manufacturing).iso/d13/oct90.arc/FOLD.LSP

Text File | 1990-11-01 | 7.8 KB | 372 lines

; Fold.Lsp   [Article Figure 2]   (c)1990, Phil Kreiker

; COPYRIGHT 1990 BY
; LOOKING GLASS MICROPRODUCTS
;
(Setq
   version "1.0"
   <180    Pi
)
;---------------------------------------
; Load-time chewing gum
;---------------------------------------
(Princ "\n")
(Setq bcount 0)
(Defun bump ()
   (Setq bcount (1+ bcount))
   (Princ
      (Strcat
         "\rFold version "
         version
         " -- Copyright 1990
by Looking Glass Microproducts : "
         (ItoA bcount)
      )
   )
)
;---------------------------------------
; Item from association list
;---------------------------------------
(bump)
(Defun item (n e)
   (CDR (Assoc n e))
)
;---------------------------------------
; Error Handler
;---------------------------------------
(bump)
(Defun bend-error (s)
   (If (/= S "Function cancelled")
      (Princ s)
   )
   (Command)
   (Command)
   (Command ".UNDO" "e")
   (If undoit
      (Progn
         (Princ "\nUndoing...")
         (Command ".U")
      )
   )
   (moder)
)
;---------------------------------------
; System variable save
;---------------------------------------
(bump)
(Defun modes (a)
   (Setq MLST Nil)
   (Repeat
      (Length a)
      (Setq
         MLST (Append
                 MLST
                 (List
                    (List
                       (CAR a)
                       (GetVar (CAR a))
                    )
                 )
              )
      )
      (Setq a (CDR a))
   )
)
;---------------------------------------
; System variable restore
;---------------------------------------
(bump)
(Defun moder ()
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
   (Setq *Error* olderror)
   (Princ)
)
;---------------------------------------
; System variable set
;---------------------------------------
(bump)
(Defun setvars (mlst)
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
)
;---------------------------------------
; Radians to Degrees
;---------------------------------------
(bump)
(Defun rtod (x)
   (/ (* 180.0 x) <180)
)
;---------------------------------------
; Mark vertices with points
;---------------------------------------
(bump)
(Defun markverts (pname / ent ename ss1)
   (Command ".ucs" "w")
   (Setq
      ent   (EntGet pname)
      Ename pname
      ss1   (SsAdd)
   )
   (While (=
             "VERTEX"
             (item
                0
                (Setq
                   Ename (EntNext Ename)
                   ent   (EntGet Ename)
                )
             )
          )
      (Redraw ename 3)
      (Command
         ".point"
         (item 10 ent)
      )
      (SsAdd (EntLast) ss1)
   )
   (Redraw pname)
   (Command ".ucs" "p")
   ss1
)
;---------------------------------------
; Bold vertices to points
;---------------------------------------
(bump)
(Defun bendverts (pname ss1
      / ent ename i pntname pntent)
   (Setq
      ent   (EntGet pname)
      Ename pname
      i     0
   )
   (While (=
             "VERTEX"
             (item
                0
                (Setq
                   Ename (EntNext Ename)
                   ent   (EntGet Ename)
                )
             )
          )
      (Redraw ename 3)
      (Setq
         pntname (SsName ss1 i)
         i       (1+ i)
         pntent  (EntGet pntname)
      )
      (EntMod
         (Subst
            (Assoc 10 pntent)
            (Assoc 10 ent)
            ent
         )
      )
   )

   ; Force a regen of the mesh such that
   ; undo and redo will regen.
   ; Entupd won't make it
   (Command
      ".move" meshname ""
      '(0 0 0) ""
   )
)
;---------------------------------------
; Returns the selection set of all
; entities which are members of both
;ss1 and ss2.
;---------------------------------------
(bump)
(Defun meet (ss1 ss2 / pt1 ssa ssb)
   (If (And ss1 ss2)
      (Progn
         (Command
            ".point"
            (GetVar "viewctr")
         )
         (Setq pt1 (EntLast))
         (Command
            ".select" pt1 ss1 "r" ss2 ""
         )
         (Setq ssa (SsGet "P"))
         (SsDel pt1 ssa)
         (Command
            ".select" pt1 ss1 "r" ssa ""
         )
         (Setq ssb (SsGet "P"))
         (SsDel pt1 ssb)
         (EntDel pt1)
         (If (> (SsLength ssb) 0) ssb)
      )
   )
)
;---------------------------------------
; GET A 3D MESH OR 3D POLYLINE
;---------------------------------------
(bump)
(Defun getmesh (/ again ename ent)
   (Setq again T)
   (While again
      (If (Setq
             ename (CAR
                      (EntSel
"\nSelect a mesh or 3D polyline: "
                      )
                   )
          )
         (Progn
            (Setq ent (EntGet ename))
            (If (And
              (= (item 0 ent)"POLYLINE")
              (>= (item 70 ent) 8)
                )
               (Progn
                 (Setq again Nil) ename)
               (Princ
"\nNot a mesh or 3D polyline."
               )
            )
         )
         (Setq again Nil)
      )
   )
)
;---------------------------------------
; GET FOLD LINE
;---------------------------------------
(Defun getbendline (/ p1 p2)
   (While (= p1 p2)
      (InitGet 1)
      (Setq
         p1 (GetPoint
"\nFirst point of fold line: "
            )
      )
      (InitGet 1)
      (Setq
       p2 (GetPoint p1 "Second point: ")
      )
      (If (= p1 p2)
         (Princ
            "\nPoints must be distinct."
         )
      )
   )
   (List p1 p2)
)
;---------------------------------------
; BEND MAIN ROUTINE
;---------------------------------------
(bump)
(Defun bend (/ ss1 ss2 meshname ok
      undoit bendline)
   (Setq
      meshname (getmesh)
      ok       meshname
   )
   (If ok
      (Progn
         (Setq bm (GetVar "blipmode"))
         (Setvar "blipmode" 0)
         (Setvar "highlight" 0)
         ;
         (Setq
            undoit T
            ss1    (markverts meshname)
; place a point on each vertex
         )
         (Setvar "blipmode" bm)
         (Prompt
            "\nSelect vertices..."
         )
         (Setq
            ss2 (meet (SsGet) ss1)
; get the vertices we wish to fold
            ok  ss2
         )
      )
   )
   (If ok
      (Progn
         (Setq bendline (getbendline))
; get the fold line
         (Command
            ".ucs" "za"
            (CAR bendline)
            (CADR bendline)
         )
         (InitGet 1)
; get the fold angle
         (Setq
            ang (rtod
                   (GetAngle
                      '(0 0 0)
                      "\nFold angle: "
                   )
                )
         )
         (Setvar "pdmode" 1)
         (Command
; rotate the vertices we wish to fold
            ".rotate" ss2 ""
            '(0 0 0) ang
         )
         (Command ".ucs" "p")
         (bendverts meshname ss1)
; fold the mesh
      )
   )
   (If ss1
      (Command ".erase" ss1 "")
; remove the markers
   )
   (Setq ss1 Nil ss2 Nil)
)
;---------------------------------------
; BEND COMMAND
;---------------------------------------
(bump)
(Defun c:fold (/ olderror undoit)
   (modes
      '("cmdecho"
         "osmode"
         "flatland"
         "elevation"
         "thickness"
         "blipmode"
         "highlight"
         "pdmode"
      )
   )
   (Setq
      olderror *Error*
      *Error*  bend-error
   )
   (setvars
      '(("cmdecho" 0)
         ("osmode" 0)
         ("flatland" 0)
         ("elevation" 0.0)
         ("thickness" 0.0)
      )
   )
   (Command ".undo" "group")
   (bend)
   (Command ".undo" "e")
   (moder)
)
(c:fold)